home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / autoload.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  21KB  |  585 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5.  
  6. ;;;;    AUTOLOAD
  7.  
  8.  
  9. ;;; Go into LISP.
  10. (in-package 'lisp)
  11.  
  12. (defun lisp-implementation-type () "Kyoto Common Lisp")
  13.  
  14. (defun machine-type () "ECLIPSE MV10000")
  15. ;(defun machine-type () "DEC VAX11/780")
  16.  
  17. (defun machine-version () "ECLIPSE MV-10000, microcode rev 2.000000")
  18. ;(defun machine-version () nil)
  19.  
  20. (defun machine-instance () "RIMS-MV10000")
  21. ;(defun machine-instance () nil)
  22.  
  23. (defun software-type () "AOS/VS")
  24. ;(defun software-type () "UNIX BSD")
  25.  
  26. (defun software-version () "AOS/VS rev 4030000")
  27. ;(defun software-version () "4.2BSD")
  28.  
  29. (defun short-site-name () "RIMS")
  30. ;(defun short-site-name () nil)
  31.  
  32. (defun long-site-name ()
  33.   "Research Institute for Mathematical Sciences, Kyoto University")
  34. ;(defun long-site-name () nil)
  35.  
  36.  
  37. ;(defvar *features*)
  38.  
  39. (defun eval-feature (x)
  40.   (cond ((atom x)
  41.          (member x *features*
  42.                  :test #'(lambda (a b)
  43.                            (cond ((symbolp a)
  44.                                   (and (symbolp b)
  45.                                        (string-equal (symbol-name a)
  46.                                                      (symbol-name b))))
  47.                                  (t (eql a b))))))
  48.         ((eq (car x) 'and)
  49.          (dolist (x (cdr x) t) (unless (eval-feature x) (return nil))))
  50.         ((eq (car x) 'or)
  51.          (dolist (x (cdr x) nil) (when (eval-feature x) (return t))))
  52.         ((eq (car x) 'not)
  53.      (not (eval-feature (cadr x))))
  54.     (t (error "~S is not a feature expression." x))))
  55.  
  56. ;;; Revised by Marc Rinfret.
  57. (defun sharp-+-reader (stream subchar arg)
  58.   (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.))
  59.                          (read stream t nil t)))
  60.       (values (read stream t nil t))
  61.       (let ((*read-suppress* t)) (read stream t nil t) (values))))
  62.  
  63. (set-dispatch-macro-character #\# #\+ 'sharp-+-reader)
  64. (set-dispatch-macro-character #\# #\+ 'sharp-+-reader
  65.                               (si::standard-readtable))
  66.  
  67. (defun sharp---reader (stream subchar arg)
  68.   (if (eval-feature (let ((*read-suppress* nil) (*read-base* 10.))
  69.                          (read stream t nil t)))
  70.       (let ((*read-suppress* t)) (read stream t nil t) (values))
  71.       (values (read stream t nil t))))
  72.  
  73. (set-dispatch-macro-character #\# #\- 'sharp---reader)
  74. (set-dispatch-macro-character #\# #\- 'sharp---reader
  75.                               (si::standard-readtable))
  76.  
  77. #| A long time ago, there was a technology called AUTOLOADING.
  78.  
  79. ;;; Autoloaders.
  80.  
  81. (defmacro defautoload (name module)
  82.   `(defun ,name (&rest argument-list)
  83.      (autoloader ',name ,module argument-list)))
  84.  
  85. (defun autoloader (name module argument-list)
  86.   (unless (member module *modules* :test #'string-equal)
  87.           (fmakunbound name)
  88.           (load (merge-pathnames module si::*system-directory*)))
  89.   (apply name argument-list))
  90.  
  91. (defmacro defautoloadmacro (name module)
  92.   `(defmacro ,name (&rest argument-list)
  93.      (autoloadermacro ',name ,module argument-list)))
  94.  
  95. (defun autoloadermacro (name module argument-list)
  96.   ;(fmakunbound name)
  97.   (load (merge-pathnames module si::*system-directory*))
  98.   (funcall (macro-function name) (cons name argument-list) nil))
  99.  
  100.  
  101. ;;; DEFAUTOLOAD definitions.
  102.  
  103. (defautoload abs "numlib")
  104. (defautoload acos "numlib")
  105. (defautoload acosh "numlib")
  106. (defautoload adjust-array "arraylib")
  107. (defautoload apropos "packlib")
  108. (defautoload apropos-list "packlib")
  109. (defautoload array-dimensions "arraylib")
  110. (defautoload array-in-bounds-p "arraylib")
  111. (defautoload array-row-major-index "arraylib")
  112. (defautoload asin "numlib")
  113. (defautoload asinh  "numlib")
  114. (defautoload atanh "numlib")
  115. (defautoload bit "arraylib")
  116. (defautoload bit-and "arraylib")
  117. (defautoload bit-andc1 "arraylib")
  118. (defautoload bit-andc2 "arraylib")
  119. (defautoload bit-eqv "arraylib")
  120. (defautoload bit-ior "arraylib")
  121. (defautoload bit-nand "arraylib")
  122. (defautoload bit-nor "arraylib")
  123. (defautoload bit-not "arraylib")
  124. (defautoload bit-orc1 "arraylib")
  125. (defautoload bit-orc2 "arraylib")
  126. (defautoload bit-xor "arraylib")
  127. (defautoload byte "numlib")
  128. (defautoload byte-position "numlib")
  129. (defautoload byte-size "numlib")
  130. (defautoload cis "numlib")
  131. (defautoload coerce "predlib")
  132. (defautoload concatenate "seq")
  133. (defautoload cosh "numlib")
  134. (defautoload count "seqlib")
  135. (defautoload count-if "seqlib")
  136. (defautoload count-if-not "seqlib")
  137. (defautoload decode-universal-time "mislib")
  138. (defautoload delete "seqlib")
  139. (defautoload delete-duplicates "seqlib")
  140. (defautoload delete-if "seqlib")
  141. (defautoload delete-if-not  "seqlib")
  142. (defautoload deposit-field "numlib")
  143. (defautoload describe "describe")
  144. (defautoload dpb "numlib")
  145. (defautoload dribble "iolib")
  146. (defautoload encode-universal-time "mislib")
  147. (defautoload every "seq")
  148. (defautoload fceiling "numlib")
  149. (defautoload ffloor "numlib")
  150. (defautoload fill "seqlib")
  151. (defautoload find "seqlib")
  152. (defautoload find-all-symbols "packlib")
  153. (defautoload find-if "seqlib")
  154. (defautoload find-if-not "seqlib")
  155. (defautoload fround "numlib")
  156. (defautoload ftruncate "numlib")
  157. #+unix (defautoload get-decoded-time "mislib")
  158. #+aosvs (defautoload get-universal-time "mislib")
  159. (defautoload get-setf-method "setf")
  160. (defautoload get-setf-method-multiple-value "setf")
  161. (defautoload inspect "describe")
  162. (defautoload intersection "listlib")
  163. (defautoload isqrt "numlib")
  164. (defautoload ldb "numlib")
  165. (defautoload ldb-test "numlib")
  166. (defautoload logandc1 "numlib")
  167. (defautoload logandc2 "numlib")
  168. (defautoload lognand "numlib")
  169. (defautoload lognor "numlib")
  170. (defautoload lognot "numlib")
  171. (defautoload logorc1 "numlib")
  172. (defautoload logorc2 "numlib")
  173. (defautoload logtest "numlib")
  174. (defautoload make-array "arraylib")
  175. (defautoload make-sequence "seq")
  176. (defautoload map "seq")
  177. (defautoload mask-field "numlib")
  178. (defautoload merge "seqlib")
  179. (defautoload mismatch "seqlib")
  180. (defautoload nintersection "listlib")
  181. (defautoload notany "seq")
  182. (defautoload notevery "seq")
  183. (defautoload nset-difference "listlib")
  184. (defautoload nset-exclusive-or "listlib")
  185. (defautoload nsubstitute "seqlib")
  186. (defautoload nsubstitute-if "seqlib")
  187. (defautoload nsubstitute-if-not "seqlib")
  188. (defautoload nunion "listlib")
  189. (defautoload phase "numlib")
  190. (defautoload position "seqlib")
  191. (defautoload position-if "seqlib")
  192. (defautoload position-if-not "seqlib")
  193. (defautoload prin1-to-string "iolib")
  194. (defautoload princ-to-string "iolib")
  195. (defautoload rational "numlib")
  196. (defautoload rationalize "numlib")
  197. (defautoload read-from-string "iolib")
  198. (defautoload reduce "seqlib")
  199. (defautoload remove "seqlib")
  200. (defautoload remove-duplicates "seqlib")
  201. (defautoload remove-if "seqlib")
  202. (defautoload remove-if-not "seqlib")
  203. (defautoload replace "seqlib")
  204. (defautoload sbit "arraylib")
  205. (defautoload search "seqlib")
  206. (defautoload set-difference "listlib")
  207. (defautoload set-exclusive-or "listlib")
  208. (defautoload signum "numlib")
  209. (defautoload sinh "numlib")
  210. (defautoload some "seq")
  211. (defautoload sort "seqlib")
  212. (defautoload stable-sort "seqlib")
  213. (defautoload subsetp "listlib")
  214. (defautoload substitute "seqlib")
  215. (defautoload substitute-if "seqlib")
  216. (defautoload substitute-if-not "seqlib")
  217. (defautoload subtypep "predlib")
  218. (defautoload tanh "numlib")
  219. (defautoload typep "predlib")
  220. (defautoload union "listlib")
  221. (defautoload vector "arraylib")
  222. (defautoload vector-pop "arraylib")
  223. (defautoload vector-push "arraylib")
  224. (defautoload vector-extend "arraylib")
  225. (defautoload write-to-string "iolib")
  226. (defautoload y-or-n-p "iolib")
  227. (defautoload yes-or-no-p "iolib")
  228.  
  229. (set-dispatch-macro-character #\# #\a 'si::sharp-a-reader)
  230. (set-dispatch-macro-character #\# #\A 'si::sharp-a-reader)
  231. (defautoload si::sharp-a-reader "iolib")
  232. (set-dispatch-macro-character #\# #\s 'si::sharp-s-reader)
  233. (set-dispatch-macro-character #\# #\S 'si::sharp-s-reader)
  234. (defautoload si::sharp-s-reader "iolib")
  235.  
  236.  
  237. ;;; DEFAUTOLOADMACRO definitions.
  238.  
  239. (defautoloadmacro assert "assert")
  240. (defautoloadmacro ccase "assert")
  241. (defautoloadmacro check-type "assert")
  242. (defautoloadmacro ctypecase "assert")
  243. (defautoloadmacro decf "setf")
  244. (defautoloadmacro define-modify-macro "setf")
  245. (defautoloadmacro define-setf-method "setf")
  246. (defautoloadmacro defsetf "setf")
  247. (defautoloadmacro defstruct "defstruct")
  248. (defautoloadmacro deftype "predlib")
  249. (defautoloadmacro do-all-symbols "packlib")
  250. (defautoloadmacro do-external-symbols "packlib")
  251. (defautoloadmacro do-symbols "packlib")
  252. (defautoloadmacro ecase "assert")
  253. (defautoloadmacro etypecase "assert")
  254. (defautoloadmacro incf "setf")
  255. (defautoloadmacro pop "setf")
  256. (defautoloadmacro push "setf")
  257. (defautoloadmacro pushnew "setf")
  258. (defautoloadmacro remf "setf")
  259. (defautoloadmacro rotatef "setf")
  260. (defautoloadmacro setf "setf")
  261. (defautoloadmacro shiftf "setf")
  262. (defautoloadmacro step "trace")
  263. (defautoloadmacro time "mislib")
  264. (defautoloadmacro trace "trace")
  265. (defautoloadmacro typecase "assert")
  266. (defautoloadmacro untrace "trace")
  267. (defautoloadmacro with-input-from-string "iolib")
  268. (defautoloadmacro with-open-file "iolib")
  269. (defautoloadmacro with-open-stream "iolib")
  270. (defautoloadmacro with-output-to-string "iolib")
  271.  
  272. |#
  273.  
  274. ;;; Compiler functions.
  275.  
  276. (defun proclaim (d)
  277.        (when (eq (car d) 'special) (mapc #'si:*make-special (cdr d))))
  278.  
  279. (defun proclamation (d)
  280.   (and (eq (car d) 'special)
  281.        (dolist (var (cdr d) t)
  282.                (unless (si:specialp var) (return nil)))))
  283.  
  284. (defun compile-file (&rest args)
  285.        (error "COMPILE-FILE is not defined in this load module."))
  286. (defun compile (&rest args)
  287.        (error "COMPILE is not defined in this load module."))
  288. (defun disassemble (&rest args)
  289.        (error "DISASSEMBLE is not defined in this load module."))
  290.  
  291.  
  292. ;;; Editor.
  293.  
  294. #+unix
  295. (defun get-decoded-time ()
  296.   (decode-universal-time (get-universal-time)))
  297.  
  298. #-unix
  299. (defun get-universal-time ()
  300.   (multiple-value-bind (sec min h d m y dow dstp tz)
  301.       (get-decoded-time)
  302.     (encode-universal-time sec min h d m y tz)))
  303.  
  304. #+unix
  305. (defun ed (&optional filename)
  306.   (system (format nil "vi ~A" filename)))
  307.  
  308. #+aosvs
  309. (progn
  310. (defvar *ed-filename* "GAZONK.LSP")
  311. (defvar *ed-position* "0")
  312.  
  313. (defun ed (&optional filename)
  314.   (let (str str-len load-file lstart plen (delete-p nil))
  315.     (when filename
  316.           (setq filename
  317.                 (namestring (merge-pathnames filename #".LSP"))))
  318.     (when (and filename (not (string-equal *ed-filename* filename)))
  319.           (setq *ed-position* "0")
  320.           (setq *ed-filename* filename))
  321.     (process (format nil "~A"
  322.                      (namestring (merge-pathnames "FECL2.PR"
  323.                                                   si::*system-directory*)))
  324.              (format nil "FECL2/LISP,~A,~D" *ed-filename* *ed-position*)
  325.              :block t :ioc t)
  326.     (setq str (last-termination-message))
  327.     (when (or (not (stringp str)) (< (setq str-len (length str)) 21))
  328.           (return-from ed str))
  329.     (when (string/= (subseq str 0 5) "LISP ")
  330.           (return-from ed str))
  331.     (setq *ed-position* (string-left-trim '(#\Space) (subseq str 5 15)))
  332.     (setq plen (parse-integer (subseq str 16 19)))
  333.     (setq *ed-filename* (subseq str 20 (+ 20 plen)))
  334.     (setq lstart (+ 21 plen))
  335.     (when (> str-len lstart)
  336.           (setq str (subseq str lstart str-len))
  337.           (unwind-protect
  338.            (progn (setq delete-p (if (char= (char str 1) #\T) t nil))
  339.                   (load (setq load-file (subseq str 2 (length str)))))
  340.            (when delete-p (delete-file (truename load-file)))))
  341.     t))
  342. )
  343.  
  344.  
  345. ;;; Allocator.
  346.  
  347. (export '(allocate allocated-pages maximum-allocatable-pages
  348.           allocate-contiguous-pages
  349.           allocated-contiguous-pages maximum-contiguous-pages
  350.           allocate-relocatable-pages allocated-relocatable-pages 
  351.           cfun cclosure spice structure))
  352.  
  353. (defconstant type-character-alist
  354.              '((cons . #\.)
  355.                (fixnum . #\N)
  356.                (bignum . #\B)
  357.                (ratio . #\R)
  358.                (short-float . #\F)
  359.                (long-float . #\L)
  360.                (complex . #\C)
  361.                (character . #\#)
  362.                (symbol . #\|)
  363.                (package . #\:)
  364.                (hash-table . #\h)
  365.                (array . #\a)
  366.                (vector . #\v)
  367.                (string . #\")
  368.                (bit-vector . #\b)
  369.                (structure . #\S)
  370.                (stream . #\s)
  371.                (random-state . #\$)
  372.                (readtable . #\r)
  373.                (pathname . #\p)
  374.                (cfun . #\f)
  375.                (cclosure . #\c)
  376.                (spice . #\!)))
  377.  
  378. (defun get-type-character (type)
  379.   (let ((a (assoc type type-character-alist)))
  380.     (unless a
  381.             (error "~S is not an implementation type.~%~
  382.                    It should be one of:~%~
  383.                    ~{~10T~S~^~30T~S~^~50T~S~%~}~%"
  384.                    type
  385.                    (mapcar #'car type-character-alist)))
  386.     (cdr a)))
  387.  
  388. (defun allocate (type quantity &optional really-allocate)
  389.   (si:alloc (get-type-character type) quantity really-allocate))
  390.  
  391. (defun allocated-pages (type)
  392.   (si:npage (get-type-character type)))
  393.  
  394. (defun maximum-allocatable-pages (type)
  395.   (si:maxpage (get-type-character type)))
  396.  
  397. (defun allocate-contiguous-pages (quantity &optional really-allocate)
  398.   (si::alloc-contpage quantity really-allocate))
  399.  
  400. (defun allocated-contiguous-pages ()
  401.   (si:ncbpage))
  402.  
  403. (defun maximum-contiguous-pages ()
  404.   (si::maxcbpage))
  405.  
  406. (defun allocate-relocatable-pages (quantity &optional really-allocate)
  407.   (si::alloc-relpage quantity))
  408.  
  409. (defun allocated-relocatable-pages ()
  410.   (si::nrbpage))
  411.  
  412. (defvar *type-list*
  413.         '(cons
  414.           fixnum bignum ratio short-float long-float complex
  415.           character symbol package hash-table
  416.           array vector string bit-vector
  417.           structure stream random-state readtable pathname
  418.           cfun cclosure spice))
  419.  
  420. (defun room (&optional x)
  421.   (let ((l (multiple-value-list (si:room-report)))
  422.         maxpage leftpage ncbpage maxcbpage ncb cbgbccount npage
  423.         rbused rbfree nrbpage
  424.         info-list link-alist)
  425.     (setq maxpage (nth 0 l) leftpage (nth 1 l)
  426.           ncbpage (nth 2 l) maxcbpage (nth 3 l) ncb (nth 4 l)
  427.           cbgbccount (nth 5 l)
  428.           holepage (nth 6 l)
  429.           rbused (nth 7 l) rbfree (nth 8 l) nrbpage (nth 9 l)
  430.           rbgbccount (nth 10 l)
  431.           l (nthcdr 11 l))
  432.     (do ((l l (nthcdr 5 l))
  433.          (tl *type-list* (cdr tl))
  434.          (i 0 (+ i (if (nth 2 l) (nth 2 l) 0))))
  435.         ((null l) (setq npage i))
  436.       (let ((typename (car tl))
  437.             (nused (nth 0 l))
  438.             (nfree (nth 1 l))
  439.             (npage (nth 2 l))
  440.             (maxpage (nth 3 l))
  441.             (gbccount (nth 4 l)))
  442.         (if nused
  443.             (push (list typename npage maxpage
  444.                         (if (zerop (+ nused nfree))
  445.                             0
  446.                             (/ nused 0.01 (+ nused nfree)))
  447.                         (if (zerop gbccount) nil gbccount))
  448.                   info-list)
  449.             (let ((a (assoc (nth nfree *type-list*) link-alist)))
  450.                  (if a
  451.                      (nconc a (list typename))
  452.                      (push (list (nth nfree *type-list*) typename)
  453.                            link-alist))))))
  454.     (dolist (info (reverse info-list))
  455.       (apply #'format t "~4D/~D~10T~5,1F%~@[~3D~]~20T~{~A~^ ~}"
  456.              (append (cdr info)
  457.                      (if  (assoc (car info) link-alist)
  458.                           (list (assoc (car info) link-alist))
  459.                           (list (list (car info))))))
  460.       (terpri)
  461.       )
  462.     (terpri)
  463.     (format t "~4D/~D~16T~@[~3D~]~20Tcontiguous (~D blocks)~%"
  464.             ncbpage maxcbpage (if (zerop cbgbccount) nil cbgbccount) ncb)
  465.     (format t "~5T~D~20Thole~%" holepage)
  466.     (format t "~5T~D~10T~5,1F%~@[~3D~]~20Trelocatable~%~%"
  467.             nrbpage (/ rbused 0.01 (+ rbused rbfree))
  468.             (if (zerop rbgbccount) nil rbgbccount))
  469.     (format t "~5D pages for cells~%" npage)
  470.     (format t "~5D total pages~%" (+ npage ncbpage holepage nrbpage))
  471.     (format t "~5D pages available~%" leftpage)
  472.     (format t "~5D maximum pages~%" maxpage)
  473.     (values)
  474.     ))
  475.  
  476.  
  477. ;;; C Interface.
  478.  
  479. (defmacro Clines (&rest r) nil)
  480. (defmacro defCfun (&rest r) nil)
  481. (defmacro defentry (&rest r) nil)
  482.  
  483. (defmacro defla (&rest r) (cons 'defun r))
  484.  
  485. ;;; Help.
  486.  
  487. (export '(help help*))
  488.  
  489. (defun help (&optional (symbol nil s))
  490.   (if s (si::print-doc symbol)
  491.       (progn
  492.         (princ "
  493. Welcome to Kyoto Common Lisp (KCL for short).
  494. Here are the few functions you should learn first.
  495.  
  496.     (HELP symbol) prints the online documentation associated with the
  497.     symbol.  For example, (HELP 'CONS) will print the useful information
  498.     about the CONS function, the CONS data type, and so on.
  499.  
  500.     (HELP* string) prints the online documentation associated with those
  501.     symbols whose print-names have the string as substring.  For example,
  502.     (HELP* \"PROG\") will print the documentation of the symbols such as
  503.     PROG, PROGN, and MULTIPLE-VALUE-PROG1.
  504.  
  505.     (BYE) ends the current KCL session.
  506.  
  507. For the precise language specification, refere to Guy Steele's \"Common Lisp,
  508. the Language\" and our \"KCL Report\".  \"KCL Dictionary\", the hard-copied
  509. version of KCL online documentation, will be useful as a handbook.
  510.  
  511. Good luck!                 Taiichi Yuasa and Masami Hagiya
  512.                         Kyoto, Japan; March 1986")
  513.         (values))))
  514.  
  515. (defun help* (string &optional (package (find-package "LISP")))
  516.   (si::apropos-doc string package))
  517.  
  518. ;;; Pretty-print-formats.
  519. ;;;
  520. ;;;    The number N as the property of a symbol SYMBOL indicates that,
  521. ;;;    in the form (SYMBOL f1 ... fN fN+1 ... fM), the subforms fN+1,...,fM
  522. ;;;    are the 'body' of the form and thus are treated in a special way by
  523. ;;;    the KCL pretty-printer.
  524.  
  525. (setf (get 'lambda 'si:pretty-print-format) 1)
  526. (setf (get 'lambda-block 'si:pretty-print-format) 2)
  527. (setf (get 'lambda-closure 'si:pretty-print-format) 4)
  528. (setf (get 'lambda-block-closure 'si:pretty-print-format) 5)
  529.  
  530. (setf (get 'block 'si:pretty-print-format) 1)
  531. (setf (get 'case 'si:pretty-print-format) 1)
  532. (setf (get 'catch 'si:pretty-print-format) 1)
  533. (setf (get 'ccase 'si:pretty-print-format) 1)
  534. (setf (get 'clines 'si:pretty-print-format) 0)
  535. (setf (get 'compiler-let 'si:pretty-print-format) 1)
  536. (setf (get 'cond 'si:pretty-print-format) 0)
  537. (setf (get 'ctypecase 'si:pretty-print-format) 1)
  538. (setf (get 'defcfun 'si:pretty-print-format) 2)
  539. (setf (get 'define-setf-method 'si:pretty-print-format) 2)
  540. (setf (get 'defla 'si:pretty-print-format) 2)
  541. (setf (get 'defmacro 'si:pretty-print-format) 2)
  542. (setf (get 'defsetf 'si:pretty-print-format) 3)
  543. (setf (get 'defstruct 'si:pretty-print-format) 1)
  544. (setf (get 'deftype 'si:pretty-print-format) 2)
  545. (setf (get 'defun 'si:pretty-print-format) 2)
  546. (setf (get 'do 'si:pretty-print-format) 2)
  547. (setf (get 'do* 'si:pretty-print-format) 2)
  548. (setf (get 'do-symbols 'si:pretty-print-format) 1)
  549. (setf (get 'do-all-symbols 'si:pretty-print-format) 1)
  550. (setf (get 'do-external-symbols 'si:pretty-print-format) 1)
  551. (setf (get 'dolist 'si:pretty-print-format) 1)
  552. (setf (get 'dotimes 'si:pretty-print-format) 1)
  553. (setf (get 'ecase 'si:pretty-print-format) 1)
  554. (setf (get 'etypecase 'si:pretty-print-format) 1)
  555. (setf (get 'eval-when 'si:pretty-print-format) 1)
  556. (setf (get 'flet 'si:pretty-print-format) 1)
  557. (setf (get 'labels 'si:pretty-print-format) 1)
  558. (setf (get 'let 'si:pretty-print-format) 1)
  559. (setf (get 'let* 'si:pretty-print-format) 1)
  560. (setf (get 'locally 'si:pretty-print-format) 0)
  561. (setf (get 'loop 'si:pretty-print-format) 0)
  562. (setf (get 'macrolet 'si:pretty-print-format) 1)
  563. (setf (get 'multiple-value-bind 'si:pretty-print-format) 2)
  564. (setf (get 'multiple-value-prog1 'si:pretty-print-format) 1)
  565. (setf (get 'prog 'si:pretty-print-format) 1)
  566. (setf (get 'prog* 'si:pretty-print-format) 1)
  567. (setf (get 'prog1 'si:pretty-print-format) 1)
  568. (setf (get 'prog2 'si:pretty-print-format) 2)
  569. (setf (get 'progn 'si:pretty-print-format) 0)
  570. (setf (get 'progv 'si:pretty-print-format) 2)
  571. (setf (get 'return 'si:pretty-print-format) 0)
  572. (setf (get 'return-from 'si:pretty-print-format) 1)
  573. (setf (get 'tagbody 'si:pretty-print-format) 0)
  574. (setf (get 'the 'si:pretty-print-format) 1)
  575. (setf (get 'throw 'si:pretty-print-format) 1)
  576. (setf (get 'typecase 'si:pretty-print-format) 1)
  577. (setf (get 'unless 'si:pretty-print-format) 1)
  578. (setf (get 'unwind-protect 'si:pretty-print-format) 0)
  579. (setf (get 'when 'si:pretty-print-format) 1)
  580. (setf (get 'with-input-from-string 'si:pretty-print-format) 1)
  581. (setf (get 'with-open-file 'si:pretty-print-format) 1)
  582. (setf (get 'with-open-stream 'si:pretty-print-format) 1)
  583. (setf (get 'with-output-to-string 'si:pretty-print-format) 1)
  584.  
  585.